JCSM Shareware Collection 1993 November/JCSM Shareware Collection - 1993-11.iso/cl720/qbnws33j.lzh/XMODEM.BAS

BASIC Source File | 1992-10-23 | 32KB | 727 lines

'  ╔═══════════════════════════════════════════════════════════════════╗
'  ║                                                                   ║
'  ║   XMODEM.BAS                                Author: Bryan Leggo   ║
'  ║                                                                   ║
'  ║   Original XModem, XModem-CRC, and XModem-1K Transfer Protocols   ║
'  ║                                                                   ║
'  ║   Uses standard QuickLibrary for "FileExists" function. Use /L    ║
'  ║   for QB.QLB in environment or the .LIB while compiling.          ║
'  ║                                                                   ║
'  ╚═══════════════════════════════════════════════════════════════════╝

DECLARE FUNCTION CalcCheckSum% (Blk$)
DECLARE FUNCTION CalcCRC& (X$, CRCHigh%, CRCLow%)
DECLARE FUNCTION FileExists% (T$, Attrib%)
DECLARE FUNCTION NoCarrier% ()
DECLARE FUNCTION TimedGet$ (Limit&, Cancelled%)
DECLARE FUNCTION Warn$ (Message$)
DECLARE SUB ClrLn (Ln%, Spaces%)
DECLARE SUB OpenCom (ComChan%, Param$)
DECLARE SUB PurgeBuffer ()
DECLARE SUB ReceiveXModem (BlkSize%, F$)
DECLARE SUB SendXModem (BlkSize%, F$)
DECLARE SUB SimpleTerminal ()
DECLARE SUB Txt (Side$, T$)
DECLARE SUB Transfer (WhichWay$)
DECLARE SUB VidBar (BarOn%, Col%, Length%)

TYPE RegTypeX                                   'Register Type for
   ax    AS INTEGER                             ' Interrupt Calls
   bx    AS INTEGER
   cx    AS INTEGER                             'AX = AH AL
   dx    AS INTEGER                             'BX = BH BL, etc.
   bp    AS INTEGER
   si    AS INTEGER
   di    AS INTEGER
   Flags AS INTEGER
   ds    AS INTEGER
   es    AS INTEGER
END TYPE

CONST TRUE = -1, FALSE = 0                      'Boolean Constants

DEFINT A-Z

DIM SHARED CR$, LF$, BS$, Escape$               'Global String Constants
DIM SHARED Lft$, Rght$, Up$, Down$
DIM SHARED PgUp$, PgDown$
DIM SHARED XOn$, XOff$
DIM SHARED Ack$, Nak$, Soh$, Stx$, Eot$, Can$   'Protocol Pseudo-Constants
DIM SHARED ComBase, Baud&
DIM SHARED Txt1st, TxtMax                       'Used by Txt Sub
DIM SHARED Kolor, BGKolor                       'Screen Colors
DIM SHARED ErrCode, ErrCt                       'Error Number & Count

'===========================================================================
'                  I N I T I A L I Z E     V A R I A B L E S
'===========================================================================

CR$ = CHR$(13): LF$ = CHR$(10): BS$ = CHR$(8): Escape$ = CHR$(27)
Up$ = CHR$(0) + CHR$(72): Down$ = CHR$(0) + CHR$(80)
Lft$ = CHR$(0) + CHR$(75): Rght$ = CHR$(0) + CHR$(77)
PgUp$ = CHR$(0) + CHR$(73): PgDown$ = CHR$(0) + CHR$(81)
XOn$ = CHR$(17): XOff$ = CHR$(19): Ack$ = CHR$(6): Nak$ = CHR$(21)
Soh$ = CHR$(1): Stx$ = CHR$(2): Eot$ = CHR$(4): Can$ = CHR$(24)

Baud& = 2400                                       'Set the BaudRate
Param$ = STR$(Baud&) + ",N,8,1,RS,OP,CD0,DS0"      ' and Com Parameters


'===========================================================================
'                         M A I N     P R O G R A M
'===========================================================================

OpenCom 1, Param$                               'Open Port 1 with Parameters$
SimpleTerminal                                  'Terminal Mode
END






'***************************************************************************
'                        E R R O R     H A N D L E R
'***************************************************************************

Handler:
ErrCode = ERR                               'Copy Err # to Global Var
ErrCt = ErrCt + 1                           'Try Statement Causing the Error
IF ErrCt MOD 3 = 0 THEN                     ' Twice Before Giving Up and
   RESUME NEXT: ErrCt = 0                   ' Going to the Next Statement
ELSE
   RESUME
END IF

FUNCTION CalcCheckSum (Blk$)                'Returns CheckSum on Blk$

C& = 0                                      'Use Long Int to Avoid Overflow
FOR Q = 1 TO LEN(Blk$)
   C& = C& + ASC(MID$(Blk$, Q, 1))          'Add to Add Bits of Each Byte
NEXT Q
C& = (C& AND 255)                           'AND Out Hi Byte Bits
CalcCheckSum = C&
END FUNCTION

FUNCTION CalcCRC& (B$, CRCHigh%, CRCLow%)      'Calculates CRC for Each Block

DIM Power(0 TO 7)                              'For the 8 Powers of 2
DIM CRC AS LONG

FOR I = 0 TO 7                                 'Calculate Once Per Block to
   Power(I) = 2 ^ I                            ' Increase Speed Within FOR J
NEXT I                                         ' Loop
CRC = 0                                        'Reset for Each Text Block
FOR I = 1 TO LEN(B$)                           'Calculate for Length of Block
   ByteVal = ASC(MID$(B$, I, 1))
   FOR J = 7 TO 0 STEP -1
      TestBit = ((CRC AND 32768) = 32768) XOR ((ByteVal AND Power(J)) = Power(J))
      CRC = ((CRC AND 32767&) * 2&)
      IF TestBit THEN CRC = CRC XOR &H1021&     ' <-- This for 16 Bit CRC
      '*** IF TestBit THEN CRC = CRC XOR &H8005&     ' <-- This for 32 Bit CRC
   NEXT J
NEXT I
CRCHigh% = (CRC \ 256)                          'Break Word Down into Bytes
CRCLow% = (CRC MOD 256)                         ' for Comparison Later
ComputeCRC& = CRC                               'Return the Word Value
END FUNCTION

REM $DYNAMIC
SUB ClrLn (Ln, Spaces)                       'Clears Line from Left Side
LOCATE Ln, 1, 0: PRINT SPACE$(Spaces);       ' for Number of Designated
LOCATE Ln, 1                                 ' Spaces. Returns Cursor to
END SUB                                      ' to First Column Afterwards

REM $STATIC
FUNCTION FileExists (T$, Attrib)     'True if File T$ Exists else False

DIM F AS STRING * 64
DIM Inx AS RegTypeX
DIM Outx AS RegTypeX

Inx.ax = &H2F00                      'Function 2FH Gets the DTA Address in
CALL INTERRUPTX(&H21, Inx, Outx)     ' ES:BX
DTASeg = Outx.es
DTAAddr = Outx.bx
F$ = LTRIM$(RTRIM$(UCASE$(T$))) + CHR$(0)

Inx.ds = VARSEG(F$)                  'Pass the File Specs by Giving Address
Inx.dx = VARPTR(F$)                  ' of String that Contains Specification
Inx.ax = &H4E00                      'Function 4EH for Find 1st Matching Entry
Inx.cx = Attrib                      'CX = Directory Attribute (0=Files Only)
CALL INTERRUPTX(&H21, Inx, Outx)     'Use Interrupt 21H
IF Outx.Flags AND 1 THEN
   FileExists = FALSE
ELSE
   FileExists = TRUE
END IF

END FUNCTION

REM $DYNAMIC
FUNCTION NoCarrier

DEF SEG = &H40
IF (INP(ComBase + 6) AND 128) = 0 THEN NoCarrier = TRUE ELSE NoCarrier = FALSE
DEF SEG

END FUNCTION

REM $STATIC
SUB OpenCom (ComChan, Param$)

CLOSE 1
SELECT CASE ComChan                   'Will Require Swapping at &H400, &H402
CASE 1                                ' Order to Support Com 3 and 4
   ComBase = &H3F8
   OPEN "R", 1, "COM1:" + Param$
CASE 2
   ComBase = &H2F8
   OPEN "R", 1, "COM2:" + Param$
END SELECT

END SUB

SUB PurgeBuffer                                    'Clear Comm Line of Chars

Mark& = TIMER                                      'Mark Starting Time
DO
   IF NOT EOF(1) THEN                              'Get More Chars While Some
      JunkIt$ = INPUT$(1, 1): Mark& = TIMER        ' In the Buffer and it's
   END IF                                          ' Less Than 1/2 Second
LOOP UNTIL EOF(1) AND (ABS(TIMER - Mark&) > .5)    ' Since Last Char Gotten
END SUB

SUB ReceiveXModem (BlkSize, F$)                 '(Block Size and Filename)
DIM B$(1 TO 4)                                  'Temp Storage of Block Bytes

CLOSE 9: OPEN "O", #9, F$                       'Save File to Channel #9
PRINT #1, XOff$; XOn$;
Cancels$ = STRING$(3, Can$)
Underway = FALSE                                'True After 1st Pkt Confirmed
Blocks = 1                                      'Block/Pkt Counter (1-Max)
BlkNum = 1                                      'Packet Block Number (1-255)
Bad = 0                                         'Bad Packets/Error Count
BCt = 0                                         'RAM Block Ptr for B$()
PurgeBuffer                                     'Get Rid of Extra Chars
CrcMode = TRUE: PktSize = BlkSize + 5           'Try CRC Mode First
PRINT #1, "C";                                  'Send "C" to Signal It


GetPacket:                                      'Get Packet of Bytes
IF NoCarrier THEN ErrType = 13: GOTO ShowErr    'Are We Still Online?
Pkt$ = ""
FOR Tries = 1 TO 10                             'Allow 10 Tries
   W$ = TimedGet$(8, Cancelled)                 'Get Response/1st Char of Pkt
   IF Cancelled THEN ErrType = 11: GOTO ShowErr 'Quit If User Cancelled
   SELECT CASE W$                               '1st Byte Is:
   CASE Soh$: BlkSize = 128: EXIT FOR           'Soh = 128 Byte Block Coming
   CASE Stx$: BlkSize = 1024: EXIT FOR          'Stx = 1K Block Coming
   CASE Eot$: GOTO ReceptionDone                'End of Xmission. Close Out.
   CASE Can$: EXIT FOR                          'Cancelled by Sender
   CASE ""                                      'No Char In Means Timed Out
      Bad = Bad + 1: LOCATE 7, 40
      PRINT "Tries:"; Tries; TAB(80);
   CASE ELSE                                    'Else Didn't Get An Expected
      PurgeBuffer                               ' Response So Purge Characters
   END SELECT
   IF NOT Underway THEN                         'Handshaking Not Complete Yet
      IF Tries < 4 THEN                         ' So Send Out Init Char Again
         CrcMode = TRUE: PRINT #1, "C";         ' Send a "C" to Start CRC or
      ELSE                                      ' a <Nak> for Standard Mode
         CrcMode = FALSE: PRINT #1, Nak$;
      END IF
   END IF
   IF Bad >= 10 THEN                            'Have Reached the Max of 10
      ErrType = 14: PurgeBuffer: GOTO ShowErr   ' Errors from TimeOuts or
   END IF                                       ' Bad Packets so Abort
NEXT Tries
IF CrcMode THEN                                 'Blk Size Determined by <Soh>
   PktSize = BlkSize + 5                        ' or <Stx>, PacketSize by
ELSE                                            ' BlockSize and Type of Check
   PktSize = BlkSize + 4                        ' Used (1 Extra Byte for CRC)
END IF
Pkt$ = W$                                       'We've Got the First Byte
WHILE LEN(Pkt$) <= PktSize - 1                  'Now Get Rest of Packet
   W$ = TimedGet$(4, Cancelled)
   IF Cancelled THEN ErrType = 11: GOTO ShowErr
   IF LEN(W$) THEN                              'If There is a Byte then Add
      Pkt$ = Pkt$ + W$                          ' it to the Packet
      IF LEFT$(Pkt$, 3) = Cancels$ THEN         'Packet Starting with Three
         PRINT #1, Cancels$; Ack$;              ' <Can>s Is a Cancellation So
         ErrType = 12: GOTO ShowErr             ' <Ack>nowledge And Abort
      END IF
   ELSE                                         'Else Null Means We Timed Out
      Bad = Bad + 1
      LOCATE 7, 40: PRINT TAB(80);
      LOCATE 7, 40: PRINT "Character Timeout. Errors:"; Bad;
      GOTO CheckPacket
   END IF
WEND

CheckPacket:                                              'Check Packet Errors
IF LEN(Pkt$) = PktSize THEN                               'If Packet Right Size
   IF BlkNum = ASC(MID$(Pkt$, 2, 1)) + 1 AND (BlkNum XOR 255) = ASC(MID$(Pkt$, 3, 1)) THEN
      ErrType = 7: GOTO ShowErr                           'Repeated Block #
   ELSEIF BlkNum <> ASC(MID$(Pkt$, 2, 1)) THEN            'Block Counts Don't
      ErrType = 5: GOTO ShowErr                           ' Match. Try New Pkt
   ELSEIF (BlkNum XOR 255) <> ASC(MID$(Pkt$, 3, 1)) THEN  'Block Ct Complement
      ErrType = 6: GOTO ShowErr                           ' Mismatch. Try New
   END IF                                                 ' Packet
   Blk$ = MID$(Pkt$, 4, BlkSize)                          'Else Copy the Block
   IF CrcMode THEN                                        'Do CheckSum or CRC
      J& = CalcCRC&(Blk$, Hi, Low)
      IF Hi <> ASC(MID$(Pkt$, PktSize - 1, 1)) THEN ErrType = 4: GOTO ShowErr
      IF Low <> ASC(MID$(Pkt$, PktSize, 1)) THEN ErrType = 4: GOTO ShowErr
   ELSE
      ChkSum = CalcCheckSum(Blk$)
      IF ChkSum <> ASC(MID$(Pkt$, PktSize, 1)) THEN ErrType = 3: GOTO ShowErr
   END IF
   GOSUB ShowProgress                             'Displays Xfer Status
   BlkNum = 255 AND (BlkNum + 1)                  'Success Thru All CheckPts
   Blocks = Blocks + 1: Bad = 0                   ' so Increment Block Cts
   Underway = TRUE                                ' Mark Handshake Completed
   IF BlkSize = 1024 THEN                         'For Xmodem-1k Write to Disk
      PRINT #9, Blk$;                             ' Immediately
   ELSE
      BCt = BCt + 1: B$(BCt) = Blk$               'Else Save 4 Blocks In RAM
      IF BCt = 4 THEN                             ' Write them to Disk Every
         PRINT #9, B$(1); B$(2); B$(3); B$(4);    ' 4th, i.e. After 512 Bytes
         BCt = 0                                  ' Reset RAM Block Index
      END IF
   END IF                                         'Acknowledge Good Block Read
   PRINT #1, Ack$;                                ' And Go to Get Next Packet
   GOTO GetPacket
ELSEIF LEN(Pkt$) < PktSize THEN                   'Packet Too Short so Show
   ErrType = 1: GOTO ShowErr                      ' Err and Get New Packet
ELSEIF LEN(Pkt$) > PktSize THEN                   'Packet Too Big so Show Err
   ErrType = 2: GOTO ShowErr                      ' And Get New Packet
ELSE                                              'Else an Unexpected Error
   ErrType = 8: GOTO ShowErr                      ' So Warn and Try for New
END IF                                            ' Packet
                                                  ' Last 2 Should NOT Occur

ReceptionDone:
IF BCt <> 0 THEN                                  'If Some Bytes Still In
   FOR I = 1 TO BCt: PRINT #9, B$(I); : NEXT I    ' Memory Then Write Them
END IF                                            ' to Disk
CLOSE 9: PRINT #1, Ack$;                          'Xmit Complete so Close
EXIT SUB                                          ' File and Send Final Ack


'---------------------------------------------------------------------------

ShowErr:
Response$ = Nak$                                  'Send Nak After Most Errors
SELECT CASE ErrType
CASE 1: ErM$ = "Short Block in #" + STR$(Blocks)
CASE 2: ErM$ = "Long Block in #" + STR$(Blocks)
CASE 3: ErM$ = "Checksum Error in #" + STR$(Blocks)
CASE 4: ErM$ = "CRC Error in #" + STR$(Blocks)
CASE 5: ErM$ = "Block # Error in #" + STR$(Blocks)
CASE 6: ErM$ = "Complement Error in #" + STR$(Blocks)
CASE 7: ErM$ = "Block # Repeated in #" + STR$(Blocks - 1): Response$ = Ack$
CASE 8: ErM$ = "Unexpected Error!"
CASE 9:
CASE 10: ErM$ = "Transfer Cancelled"
CASE 11: ErM$ = "Transfer Aborted by User"
CASE 12: ErM$ = "Transfer Aborted by Sender"
CASE 13: ErM$ = "No Carrier"
CASE 14: ErM$ = "Maximum Errors. Transfer Aborted."
END SELECT
LOCATE 7, 40: PRINT TAB(80);                      'Show the ErrorMsg
LOCATE 7, 40: PRINT ErM$;
IF ErrType < 10 THEN                              'ErrType < 10 is Recoverable
   Bad = Bad + 1                                  ' Count One More Error
   PRINT #1, Response$;                           ' Respond Nak (or Ack) and
   Pkt$ = "": GOTO GetPacket                      ' Go to Get Packet Again
ELSE
   J$ = Warn$(ErM$)                               'Notify User of Cancel
   SLEEP 2: PurgeBuffer                           'Get Rid of Remaining Pkt
   PRINT #1, STRING$(5, 24); STRING$(5, 8);       'Send 5 <Can>s & 5 <BS>s
   CLOSE 9: KILL F$                               'ErrType >= 10 is Fatal so
   EXIT SUB                                       ' Kill Off File and Quit
END IF

'---------------------------------------------------------------------------

ShowProgress:                                     'Show Byte Counts & Bar
KBytes = INT(Blocks * (BlkSize / 1024))
LOCATE 5, 40: PRINT "Received #"; Blocks; TAB(60); KBytes; "K Bytes";
IF BarLength = 0 THEN
   LOCATE 9: VidBar FALSE, 1, 80
   FOR K = 1 TO 9
      LOCATE 10, K * 8 - 1
      PRINT LTRIM$(STR$(100 * (KBytes \ 100) + (K * 10))); "K ";
   NEXT K
END IF
BarLength = INT(80 * ((KBytes MOD 100) / 100))
LOCATE 9: VidBar TRUE, 1, BarLength
RETURN



' Block refers to Block of Text from File (128 bytes, 1024 for Xmodem-1K)
' Packet Refers to Block + Extra "Control" Characters, i.e. :

'       XModem: SOH + BlockCt + Complement BlockCt + Block + CheckSum
'    XModemCRC: SOH + BlockCt + Complement BlockCt + Block + CRC (Hi & Low)
'    XModem-1K: STX + BlockCt + Complement BlockCt + Block + CheckSum
' XModemCRC-1K: STX + BlockCt + Complement BlockCt + Block + CRC (Hi & Low)

END SUB

SUB SendXModem (BlkSize, F$)                              '(Bytes, FileName$)

CLOSE 9: OPEN F$ FOR RANDOM AS 9 LEN = 128
FIELD #9, 128 AS BlkOf128$
FiLen& = LOF(9): TtlBlocks = FiLen& \ BlkSize             'Get File Length
IF FiLen& MOD BlkSize > 0 THEN TtlBlocks = TtlBlocks + 1  ' in Bytes & Blocks
LOCATE 3, 40: PRINT "Blocks:"; TtlBlocks; TAB(60);
Seconds = ((TtlBlocks * 6) + FiLen&) \ (Baud& \ 16)
Est$ = STR$(Seconds \ 3600) + STR$(Seconds \ 60) + STR$(Seconds MOD 60)
FOR I = 2 TO LEN(Est$)
   IF MID$(Est$, I, 1) = " " THEN MID$(Est$, I, 1) = ":"
NEXT I
PRINT "Est. Time:"; Est$;

ErM$ = "Transfer Aborted"                        'Generic Msg In Case of Error
Blocks = 0: BlkNum = 0                           'Blocks (1-?), BlkNum (1-255)
EoFile = FALSE: W$ = ""                          'Initialize Block, Byte,
Ct& = 0                                          'To Count Bytes Used & Sent
Bad = 0                                          'Error Counter
PurgeBuffer                                      'Clear the Com Line

DO                                               'Shake Hands with Receiver
   W$ = TimedGet$(20, Cancelled)                 'Get Initial Character
   IF Cancelled THEN GOTO AbortSend              'If User Pressed <Esc>
   SELECT CASE W$
   CASE Can$: GOTO AbortSend                     'Receiver is Cancelling
   CASE Nak$: CrcMode = FALSE: EXIT DO           'Nak for Standard XModem
   CASE "C": CrcMode = TRUE: EXIT DO             'C Indicates XModem-CRC
   END SELECT                                    'Begin After <Nak> or C
LOOP

MakePacket:
IF NoCarrier THEN                                    'Still Online?
   ErM$ = "No Carrier!": GOTO AbortSend
END IF
W$ = "": Blocks = Blocks + 1: Bad = 0                'Advance Block Counter
IF (BlkSize = 1024) AND ((Ct& + 896) > FiLen&) THEN  'If Doing 1k and at End
   BlkSize = 128                                     ' of File Then Shorten
END IF                                               ' to Avoid Extra Nulls
IF BlkSize = 128 THEN MaxBCt = 1 ELSE MaxBCt = 8     '8 Groups of 128 = 1024
BCt = 0: Blk$ = ""                                   'Build the Block$
DO
   Ct& = Ct& + 128: GET #9                           'Advance File Ptr, Get From File
   BCt = BCt + 1: Blk$ = Blk$ + BlkOf128$
   IF Ct& >= FiLen& THEN                             'If It's Last Block We're
      EoFile = TRUE                                  ' About Done Xmitting
      Pad = Ct& - FiLen&                             ' Pad the End with Nulls
      MID$(Blk$, BlkSize - Pad, Pad) = STRING$(Pad, CHR$(0))
      EXIT DO
   END IF
LOOP UNTIL BCt = MaxBCt                              'Done After 1 (8 for 1k)
BlkNum = (255 AND Blocks)                            ' So Assemble the Packet
Pkt$ = Soh$ + CHR$(BlkNum) + CHR$(BlkNum XOR 255) + Blk$
IF BlkSize = 1024 THEN MID$(Pkt$, 1, 1) = Stx$       '1st Byte is Stx for 1K
IF CrcMode THEN                                      'End of Packet Varies
   J& = CalcCRC&(Blk$, Hi%, Low%)                    ' with Check Method Used
   Pkt$ = Pkt$ + CHR$(Hi%) + CHR$(Low%)              ' 2 Bytes for CRC
ELSE
   ChkSum = CalcCheckSum(Blk$)                       ' 1 Byte for CheckSum
   Pkt$ = Pkt$ + CHR$(ChkSum)
END IF

SendPacket:
PRINT #1, Pkt$;                                      'Send the Packet and
LOCATE 5, 40: PRINT "Sending #"; Blocks;             ' Show Progress on Screen
P = INT((Blocks / TtlBlocks) * 100)                  'Calculate Percentage
IF P <= 100 THEN                                     'Percentage Can Be > 100
   LOCATE 5, 60: PRINT P; "% Complete": LOCATE 9     ' On Last Blocks of 1k
   VidBar TRUE, 1, INT((Blocks / TtlBlocks) * 80)    ' Mode Since Last 1024 is
END IF                                               ' Sent in 128 Byte Blocks

DO                                                   'Packet Has Been Sent so
   W$ = TimedGet$(10, Cancelled)                     'Get Response/Confirm
   IF Cancelled THEN GOTO AbortSend                  'Quit If User <Esc>aped
   SELECT CASE W$                                    'Interpret Response
   CASE Ack$                                         'Block Acknowledged So
      Bad = 0                                        ' Send Next Packet If
      IF EoFile THEN EXIT DO ELSE GOTO MakePacket    ' More Data
   CASE ELSE                                         'Else
      Bad = Bad + 1                                  ' Count 1 More Error
      IF Bad > 9 THEN GOTO AbortSend                 ' Abort If Over Limit
      IF W$ = Can$ THEN                              'If a <Can> Then Look
         FOR I = 1 TO 2                              ' For at Least 2 More to
            W$ = W$ + TimedGet$(2, Cancelled)        ' Be Sure (Or User Esc)
            IF Cancelled THEN GOTO AbortSend
            IF W$ = STRING$(3, Can$) THEN GOTO AbortSend
         NEXT I
         GOTO SendPacket
      ELSE
         PurgeBuffer                                 'Any Other Char Is an
         GOTO SendPacket                             ' Error So ReSend Packet
      END IF                                         ' & Look for <Ack> Again
   END SELECT
LOOP

ConcludeSend:
ErM$ = "End of Transmission": GOSUB ShowStatus       'Proper End of Transmit
CLOSE 9: PRINT #1, Eot$;                             'Close File, Send the EOT
I$ = TimedGet$(10, Cancelled)                        'Get Final Char
IF I$ = Ack$ THEN                                    'Should Be an <Ack> but
   ErM$ = "Acknowledged": GOSUB ShowStatus
ELSEIF Cancelled THEN                                'Allow User to Cancel
   EXIT SUB
ELSE                                                 'If Not an <Ack> Resend
   GOTO ConcludeSend                                 ' <Eot> and Try Again
END IF
EXIT SUB

'---------------------------------------------------------------------------

AbortSend:
J$ = Warn$(ErM$)                                 'Show Error Status
CLOSE 9                                          'Close File
PRINT #1, STRING$(5, Can$); STRING$(5, BS$);     'Send Cancel to Receiver
EXIT SUB

'---------------------------------------------------------------------------

ShowStatus:
LOCATE 7, 40: PRINT ErM$; TAB(80);               'Show the Status or ErrorMsg
RETURN

END SUB

SUB SimpleTerminal
ON ERROR GOTO Handler
FF$ = CHR$(12): Hm$ = CHR$(11)

CLS : GOSUB InfoBar
PRINT #1, "AT S0=1"                       'Send Modem Initialization String
DO
   Out$ = INKEY$                          'Look for Key Press
   IF LEN(Out$) THEN                      'If There IS One then Select
      SELECT CASE Out$
      CASE PgUp$, PgDown$                 ' to Upload or Download
         Transfer Out$: GOSUB InfoBar
      CASE Escape$                        ' Escape to End Program
         EXIT DO
      CASE CHR$(0) + CHR$(59)
         PRINT #1, "atdt 626-9456"
      CASE ELSE
         PRINT #1, Out$;                  ' Else Send the Character Verbatim
      END SELECT
   END IF
   IF LOC(1) THEN                         'Is there Incoming Data from Com?
      DO                                  ' If So then Get Chars Until No
         ComChr$ = INPUT$(1, 1)           ' More or End of a Line <LF>
         SELECT CASE ComChr$
         CASE BS$: ComChr$ = CHR$(29)     'Replace BackSpaces with CHR$(29)
         CASE FF$, Hm$: ComChr$ = ""      'Filter these Out
         CASE LF$: ComChr$ = "": EXIT DO  'Ignore Linefeeds But Exit Do Loop
         END SELECT
         PRINT ComChr$;                   'Print the Char Received On Screen
      LOOP UNTIL LOC(1) = 0               'No More Com Waiting
   END IF
LOOP
EXIT SUB

'---------------------------------------------------------------------------

InfoBar:
LOCATE 25, 1: COLOR 0, 7
PRINT " <PgUp> to Upload,  <PgDown> to Download,  <Escape> to End Program"; TAB(80); " ";
COLOR 7, 0: LOCATE 24, 1
RETURN

END SUB

FUNCTION TimedGet$ (Limit&, Cancelled)            'Timed Routine to Get One
                                                  'Character from Comm Port
Mark& = TIMER                                     'Mark Starting Time
DO
   IF NOT EOF(1) THEN                             'If Chars Waiting Then
      TimedGet$ = INPUT$(1, 1): EXIT FUNCTION     ' Return 1 Character
   END IF
   IF INKEY$ = Escape$ THEN                       'User Can Press <Esc> to
      Cancelled = TRUE: EXIT FUNCTION             ' Quit
   END IF
LOOP WHILE ABS(TIMER - Mark&) < Limit&            'Wait Up Until Past Limit
TimedGet$ = ""                                    'Return "" If Timing Out
END FUNCTION

REM $DYNAMIC
SUB Transfer (WhichWay$)                  'WhichWay = PgUp (U/L), PgDn (D/L)
ON ERROR GOTO Handler

NumProtos = 4                             'Number of Protocols Here
SendDir$ = ""                             'Define Directories Where Files Will
RecvDir$ = ""                             ' Be DownLoaded To or Uploaded From
SendExternal$ = ""                        'DOS Command Line Used to Execute
RecvExternal$ = ""                        ' External Protocol (~ for Filename)

Kolor = 0: BGKolor = 7                    'Transfer Area in Reverse Video for
COLOR Kolor, BGKolor                      ' Contrast
VIEW PRINT 1 TO 11: CLS 2: VIEW PRINT     'Clear Top 11 Lines
LOCATE 11, 1: PRINT STRING$(80, "▒");

IF WhichWay$ = PgUp$ THEN                 'Determine if Sending or Receiving
   Way$ = "Sending": Sending = TRUE       ' From Key Pressed
ELSE
   Way$ = "Receiving": Sending = FALSE
END IF
DO
   ClrLn 9, 80: PRINT "File You Are "; Way$; ": ";
   F$ = "": LINE INPUT F$
   IF F$ = "" THEN GOTO ExitTransfer
   F$ = UCASE$(F$)
   IF Sending THEN
      IF LEN(SendDir$) THEN
         IF INSTR(F$, ":") = 0 THEN F$ = SendDir$ + "\" + F$
      END IF
      IF FileExists(F$, 0) THEN Ok = TRUE ELSE J$ = Warn$("File Not Found")
   ELSE
      IF LEN(ReceiveDir$) THEN
         IF INSTR(F$, ":") = 0 THEN F$ = ReceiveDir$ + "\" + F$
      END IF
      IF FileExists(F$, 0) THEN
         ClrLn 9, 80
         PRINT F$; " Already Exists! Overwrite it? (Y/N)? ";
         DO: B$ = UCASE$(INKEY$)
         LOOP UNTIL LEN(B$) AND INSTR("YN", B$)
         IF B$ = "Y" THEN Ok = TRUE
      ELSE
         ErrCode = 0: F = FREEFILE
         OPEN "O", F, F$
         IF ErrCode THEN J$ = Warn$("Bad Path/Filename?") ELSE Ok = TRUE
         CLOSE F
      END IF
   END IF
LOOP UNTIL Ok

Txt1st = 1: TxtMax = 30                            'And Draw a Box Around
LOCATE 1, 1
PRINT TAB(40); "Choose a Protocol"; TAB(80);
Txt "T", ""
Txt "C", "       XModem       "
Txt "C", " XModem-1k (YModem) "
Txt "C", " External Protocol  "
Txt "C", "       Cancel       "
Txt "B", ""
R = 1: C = 0
DO
   LOCATE R + 1, 2, 0
   VidBar TRUE, 2, 30
   DO: C$ = INKEY$: LOOP UNTIL LEN(C$)
   VidBar FALSE, 2, 30
   SELECT CASE C$                                      'Based on Terminator:
   CASE Up$: R = R - 1: IF R < 1 THEN R = NumProtos    ' Go to Line Above
   CASE Down$: R = R + 1: IF R > NumProtos THEN R = 1  ' or Line Below
   CASE CR$: EXIT DO
   CASE Escape$: EXIT DO
   END SELECT
LOOP
IF C$ = Escape$ THEN GOTO ExitTransfer                 'Cancelled by User
VidBar TRUE, 2, 30
LOCATE 9, 1: PRINT "╟──+───┼───+───┼───+───┼───+───┼───+───║───+───┼───+───┼───+───┼───+───┼───+───╢"
LOCATE 1, 3: PRINT " Press <Escape> to Cancel "
LOCATE 1, 40: PRINT Way$; ": "; UCASE$(F$); TAB(80);
IF Sending THEN
   LOCATE 10, 1: PRINT "      10%     20%     30%     40%     50%     60%     70%     80%     90%"
   SELECT CASE R
   CASE 1: SendXModem 128, F$
   CASE 2: SendXModem 1024, F$
   CASE 3: Ext$ = SendExternal$: GOSUB InsertFileName: SHELL Ext$
   CASE 4: GOTO ExitTransfer
   END SELECT
ELSE
   SELECT CASE R
   CASE 1: ReceiveXModem 128, F$
   CASE 2: ReceiveXModem 1024, F$
   CASE 3: Ext$ = RecvExternal$: GOSUB InsertFileName: SHELL Ext$
   CASE 4: GOTO ExitTransfer
   END SELECT
END IF
PLAY "T90 O3 L32 CBCBCBCBCBCBCBCBCBCBCBCBCBCBCBC"     'All Done Warning Sound

ExitTransfer:
COLOR 7, 0                                            'Back to White on Black
VIEW PRINT 1 TO 11: CLS 2: VIEW PRINT                 'Clear Top 11 Lines
VIEW PRINT 1 TO 24: LOCATE 24, 1, 1
EXIT SUB

'----------------------------------------------------------------------------

InsertFileName:                    'Substitute FileName for ~ in Strings Used
P = INSTR(Ext$, "~")               ' to Call External Protocol (Send or Recv)
IF P > 1 THEN
   Ext$ = LEFT$(Ext$, P - 1) + F$ + RIGHT$(Ext$, LEN(Ext$) - P)
END IF
RETURN

END SUB

REM $STATIC
SUB Txt (Side$, Text$)                  'Put 1 Line of Text w/ Box Delimiters

IF LEN(Text$) > TxtMax THEN Text$ = LEFT$(Text$, TxtMax - 2)
SpaceLeft = (TxtMax - LEN(Text$)) \ 2
LOCATE , Txt1st
IF LEN(Text$) MOD 2 = 1 THEN Text$ = Text$ + " "
IF Side$ = LCASE$(Side$) THEN Shadow$ = ""
SELECT CASE UCASE$(Side$)
CASE "T"
   Text$ = "╔" + STRING$(TxtMax, "═") + "╗"                    'Top Border
   C = (TxtMax \ 2) - (LEN(T$) \ 2)
   MID$(Text$, C) = T$
CASE "B"
   Text$ = "╚" + STRING$(TxtMax, "═") + "╝"                    'Bottom Border
   C = (TxtMax \ 2) - (LEN(T$) \ 2)
   MID$(Text$, C) = T$
CASE "C"
   Text$ = "║" + STRING$(SpaceLeft, " ") + Text$ + STRING$(SpaceLeft, " ") + "║"
CASE "R"
   Text$ = "║" + STRING$(2 * SpaceLeft, " ") + Text$ + "║"     'Right-Justify
CASE "L"
   Text$ = "║" + Text$ + STRING$(2 * SpaceLeft, " ") + "║"     'Left-Justify
END SELECT

PRINT Text$; Shadow$;                                   'Print Text, DeLimits
IF CSRLIN < 24 THEN PRINT                               'Go to Next Line
IF (Side$ = "B") AND LEN(Shadow$) THEN
   IF CSRLIN = 24 THEN LOCATE 25
   LOCATE , Txt1st
   PRINT " "; STRING$(TxtMax + 1, Shadow$); Shadow$;
   Shadow$ = ""
END IF
END SUB

SUB VidBar (BarOn, Col, Length)

113 LOCATE , Col                        'Position at Paramter Column
IF BarOn THEN                           'IF Hilighting (BarOn = True) then
   COLOR BGKolor, Kolor                 ' Use the BGKolor in the FG
   FOR J = Col TO Col + Length - 1      'Across the Screen for the "Length"
      PRINT CHR$(SCREEN(CSRLIN, J));    ' Re-Print the Char That is Already
   NEXT J                               ' There in It's New Colors
ELSE
   COLOR Kolor, BGKolor                 'ELSE De-HiLiting So Return Colors
   FOR J = Col TO Col + Length - 1      ' to Normal and Re-Print each Char
      PRINT CHR$(SCREEN(CSRLIN, J));    ' in the Row with the Regular Video
   NEXT J
END IF
LOCATE , Col                            'Return to 1st Column
COLOR Kolor, BGKolor                    ' and Normal Colors
END SUB

FUNCTION Warn$ (Warning$)
LOCATE 1, 40: COLOR 20
PRINT " "; Warning$; TAB(80);
COLOR Kolor, BGKolor
BEEP: BEEP
END FUNCTION